home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / TUT14.ZIP / TUTPRO14.PAS < prev   
Pascal/Delphi Source File  |  1994-09-08  |  13KB  |  535 lines
  1. {$X+}
  2. USES Crt,GFX2;
  3.  
  4. CONST VGA = $A000;
  5.       maxpolys = 6;
  6.       A : Array [1..maxpolys,1..4,1..3] of integer =
  7.         (
  8.          ((-10,-10,10),(-10,10,10),(10,10,10),(10,-10,10)),
  9.          ((-10,-10,-10),(-10,10,-10),(10,10,-10),(10,-10,-10)),
  10.          ((-10,-10,-10),(-10,10,-10),(-10,10,10),(-10,-10,10)),
  11.          ((10,-10,-10),(10,10,-10),(10,10,10),(10,-10,10)),
  12.          ((10,-10,10),(10,-10,-10),(-10,-10,-10),(-10,-10,10)),
  13.          ((10,10,10),(10,10,-10),(-10,10,-10),(-10,10,10))
  14.         );  { The 3-D coordinates of our object ... stored as (X1,Y1,Z1), }
  15.             { (X2,Y2,Z2) ... for the 4 points of a poly }
  16.  
  17.  
  18. Type Point = Record
  19.                x,y,z:integer;                { The data on every point we rotate}
  20.              END;
  21.  
  22.  
  23. VAR Lines : Array [1..maxpolys,1..4] of Point; { The base object to be rotated }
  24.     Translated : Array [1..maxpolys,1..4] of Point; { The rotated object }
  25.     lookup : Array [0..360,1..2] of integer; { Our sin and cos lookup table }
  26.     poly : array [0..199,1..2] of integer;
  27.     ytopclip,ybotclip:integer;  {where to clip our polys to}
  28.     xoff,yoff,zoff:integer;
  29.  
  30.  
  31. {──────────────────────────────────────────────────────────────────────────}
  32. Procedure SetMCGA;  { This procedure gets you into 320x200x256 mode. }
  33. BEGIN
  34.   asm
  35.      mov        ax,0013h
  36.      int        10h
  37.   end;
  38. END;
  39.  
  40.  
  41. {──────────────────────────────────────────────────────────────────────────}
  42. Procedure Hline (x1,x2,y:word;col:byte;where:word); assembler;
  43.   { This draws a horizontal line from x1 to x2 on line y in color col }
  44. asm
  45.   mov   ax,where
  46.   mov   es,ax
  47.   mov   ax,y
  48.   mov   di,ax
  49.   shl   ax,8
  50.   shl   di,6
  51.   add   di,ax
  52.   add   di,x1
  53.  
  54.   mov   cx,x2
  55.   sub   cx,x1
  56.   cmp   cx,0
  57.   jle   @End
  58. @Loop1 :
  59.   mov   al,es:[di]
  60.   add   al,col
  61. {  inc   al}
  62.   stosb
  63.   loop  @loop1
  64. @End:
  65. end;
  66.  
  67.  
  68. {──────────────────────────────────────────────────────────────────────────}
  69. Procedure DrawPoly(x1,y1,x2,y2,x3,y3,x4,y4:integer;color:byte;where:word);
  70.   { This draw a polygon with 4 points at x1,y1 , x2,y2 , x3,y3 , x4,y4
  71.     in color col }
  72. var miny,maxy:integer;
  73.     loop1:integer;
  74.  
  75. Procedure doside (x1,y1,x2,y2:integer);
  76.   { This scans the side of a polygon and updates the poly variable }
  77. VAR temp:integer;
  78.     x,xinc:integer;
  79.     loop1:integer;
  80. BEGIN
  81.   if y1=y2 then exit;
  82.   if y2<y1 then BEGIN
  83.     temp:=y2;
  84.     y2:=y1;
  85.     y1:=temp;
  86.     temp:=x2;
  87.     x2:=x1;
  88.     x1:=temp;
  89.   END;
  90.   xinc:=((x2-x1) shl 7) div (y2-y1);
  91.   x:=x1 shl 7;
  92.   for loop1:=y1 to y2 do BEGIN
  93.     if (loop1>ytopclip-1) and (loop1<ybotclip+1) then BEGIN
  94.       if (x shr 7<poly[loop1,1]) then poly[loop1,1]:=x shr 7;
  95.       if (x shr 7>poly[loop1,2]) then poly[loop1,2]:=x shr 7;
  96.     END;
  97.     x:=x+xinc;
  98.   END;
  99. END;
  100.  
  101. begin
  102.   asm
  103.     mov   si,offset poly
  104.     mov   cx,200
  105. @Loop1:
  106.     mov   ax,32766
  107.     mov   ds:[si],ax
  108.     inc   si
  109.     inc   si
  110.     mov   ax,-32767
  111.     mov   ds:[si],ax
  112.     inc   si
  113.     inc   si
  114.     loop  @loop1
  115.   end;     { Setting the minx and maxx values to extremes }
  116.   miny:=y1;
  117.   maxy:=y1;
  118.   if y2<miny then miny:=y2;
  119.   if y3<miny then miny:=y3;
  120.   if y4<miny then miny:=y4;
  121.   if y2>maxy then maxy:=y2;
  122.   if y3>maxy then maxy:=y3;
  123.   if y4>maxy then maxy:=y4;
  124.   if miny<ytopclip then miny:=ytopclip;
  125.   if maxy>ybotclip then maxy:=ybotclip;
  126.   if (miny>199) or (maxy<0) then exit;
  127.  
  128.   Doside (x1,y1,x2,y2);
  129.   Doside (x2,y2,x3,y3);
  130.   Doside (x3,y3,x4,y4);
  131.   Doside (x4,y4,x1,y1);
  132.  
  133.   for loop1:= miny to maxy do
  134.     hline (poly[loop1,1],poly[loop1,2],loop1,color,where);
  135. end;
  136.  
  137.  
  138. {──────────────────────────────────────────────────────────────────────────}
  139. Procedure SetUpPoints;
  140.   { This creates the lookup table }
  141. VAR loop1,loop2:integer;
  142. BEGIN
  143.   For loop1:=0 to 360 do BEGIN
  144.     lookup [loop1,1]:=round(sin (rad (loop1))*16384);
  145.     lookup [loop1,2]:=round(cos (rad (loop1))*16384);
  146.   END;
  147. END;
  148.  
  149.  
  150. {──────────────────────────────────────────────────────────────────────────}
  151. Procedure RotatePoints (x,Y,z:Integer);
  152.   { This rotates the objecct in lines to translated }
  153. VAR loop1,loop2:integer;
  154.     a,b,c:integer;
  155. BEGIN
  156.   For loop1:=1 to maxpolys do BEGIN
  157.     for loop2:=1 to 4 do BEGIN
  158.       b:=lookup[y,2];
  159.       c:=lines[loop1,loop2].x;
  160.       asm
  161.         mov   ax,b
  162.         imul  c
  163.         sal   ax,1
  164.         rcl   dx,1
  165.         sal   ax,1
  166.         rcl   dx,1
  167.         mov   a,dx
  168.       end;
  169.       b:=lookup[y,1];
  170.       c:=lines[loop1,loop2].z;
  171.       asm
  172.         mov   ax,b
  173.         imul  c
  174.         sal   ax,1
  175.         rcl   dx,1
  176.         sal   ax,1
  177.         rcl   dx,1
  178.         add   a,dx
  179.       end;
  180.       translated[loop1,loop2].x:=a;
  181.       translated[loop1,loop2].y:=lines[loop1,loop2].y;
  182.       b:=-lookup[y,1];
  183.       c:=lines[loop1,loop2].x;
  184.       asm
  185.         mov   ax,b
  186.         imul  c
  187.         sal   ax,1
  188.         rcl   dx,1
  189.         sal   ax,1
  190.         rcl   dx,1
  191.         mov   a,dx
  192.       end;
  193.       b:=lookup[y,2];
  194.       c:=lines[loop1,loop2].z;
  195.       asm
  196.         mov   ax,b
  197.         imul  c
  198.         sal   ax,1
  199.         rcl   dx,1
  200.         sal   ax,1
  201.         rcl   dx,1
  202.         add   a,dx
  203.       end;
  204.       translated[loop1,loop2].z:=a;
  205.  
  206.  
  207.       if x<>0 then BEGIN
  208.         b:=lookup[x,2];
  209.         c:=translated[loop1,loop2].y;
  210.         asm
  211.           mov   ax,b
  212.           imul  c
  213.           sal   ax,1
  214.           rcl   dx,1
  215.           sal   ax,1
  216.           rcl   dx,1
  217.           mov   a,dx
  218.         end;
  219.         b:=lookup[x,1];
  220.         c:=translated[loop1,loop2].z;
  221.         asm
  222.           mov   ax,b
  223.           imul  c
  224.           sal   ax,1
  225.           rcl   dx,1
  226.           sal   ax,1
  227.           rcl   dx,1
  228.           sub   a,dx
  229.         end;
  230.         b:=lookup[x,1];
  231.         c:=translated[loop1,loop2].y;
  232.         translated[loop1,loop2].y:=a;
  233.         asm
  234.           mov   ax,b
  235.           imul  c
  236.           sal   ax,1
  237.           rcl   dx,1
  238.           sal   ax,1
  239.           rcl   dx,1
  240.           mov   a,dx
  241.         end;
  242.         b:=lookup[x,2];
  243.         c:=translated[loop1,loop2].z;
  244.         asm
  245.           mov   ax,b
  246.           imul  c
  247.           sal   ax,1
  248.           rcl   dx,1
  249.           sal   ax,1
  250.           rcl   dx,1
  251.           add   a,dx
  252.         end;
  253.         translated[loop1,loop2].z:=a;
  254.       END;
  255.  
  256.  
  257.  
  258.  
  259.       if z<>0 then BEGIN
  260.         b:=lookup[z,2];
  261.         c:=translated[loop1,loop2].x;
  262.         asm
  263.           mov   ax,b
  264.           imul  c
  265.           sal   ax,1
  266.           rcl   dx,1
  267.           sal   ax,1
  268.           rcl   dx,1
  269.           mov   a,dx
  270.         end;
  271.         b:=lookup[z,1];
  272.         c:=translated[loop1,loop2].y;
  273.         asm
  274.           mov   ax,b
  275.           imul  c
  276.           sal   ax,1
  277.           rcl   dx,1
  278.           sal   ax,1
  279.           rcl   dx,1
  280.           sub   a,dx
  281.         end;
  282.         b:=lookup[z,1];
  283.         c:=translated[loop1,loop2].x;
  284.         translated[loop1,loop2].x:=a;
  285.         asm
  286.           mov   ax,b
  287.           imul  c
  288.           sal   ax,1
  289.           rcl   dx,1
  290.           sal   ax,1
  291.           rcl   dx,1
  292.           mov   a,dx
  293.         end;
  294.         b:=lookup[z,2];
  295.         c:=translated[loop1,loop2].y;
  296.         asm
  297.           mov   ax,b
  298.           imul  c
  299.           sal   ax,1
  300.           rcl   dx,1
  301.           sal   ax,1
  302.           rcl   dx,1
  303.           add   a,dx
  304.         end;
  305.         translated[loop1,loop2].y:=a;
  306.       END;
  307.     END;
  308.   END;
  309. END;
  310.  
  311.  
  312.  
  313. {──────────────────────────────────────────────────────────────────────────}
  314. Procedure DrawPoints;
  315.   { This draws the translated object to the virtual screen }
  316. VAR loop1:Integer;
  317.     temp:integer;
  318.     nx:integer;
  319.     tx1,ty1,tx2,ty2,tx3,ty3,tx4,ty4:integer;
  320. BEGIN
  321.   For loop1:=1 to maxpolys do BEGIN
  322.     If (translated[loop1,1].z+zoff<0) and (translated[loop1,2].z+zoff<0)
  323.        and (translated[loop1,3].z+zoff<0) and (translated[loop1,4].z+zoff<0)
  324.        then BEGIN
  325.       temp:=round (translated[loop1,1].z)+zoff;
  326.       nx:=translated[loop1,1].X;
  327.       asm
  328.         mov   ax,nx
  329.         mov   dx,ax
  330.         sal   ax,8
  331.         sar   dx,8
  332.         idiv  temp
  333.         add   ax,160
  334.         mov   nx,ax
  335.       end;
  336.       tx1:=nx;
  337.       nx:=translated[loop1,1].Y;
  338.       asm
  339.         mov   ax,nx
  340.         mov   dx,ax
  341.         sal   ax,8
  342.         sar   dx,8
  343.         idiv  temp
  344.         add   ax,100
  345.         mov   nx,ax
  346.       end;
  347.       ty1:=nx;
  348.  
  349.  
  350.       temp:=round (translated[loop1,2].z)+zoff;
  351.       nx:=translated[loop1,2].X;
  352.       asm
  353.         mov   ax,nx
  354.         mov   dx,ax
  355.         sal   ax,8
  356.         sar   dx,8
  357.         idiv  temp
  358.         add   ax,160
  359.         mov   nx,ax
  360.       end;
  361.       tx2:=nx;
  362.       nx:=translated[loop1,2].Y;
  363.       asm
  364.         mov   ax,nx
  365.         mov   dx,ax
  366.         sal   ax,8
  367.         sar   dx,8
  368.         idiv  temp
  369.         add   ax,100
  370.         mov   nx,ax
  371.       end;
  372.       ty2:=nx;
  373.  
  374.  
  375.       temp:=round (translated[loop1,3].z)+zoff;
  376.       nx:=translated[loop1,3].X;
  377.       asm
  378.         mov   ax,nx
  379.         mov   dx,ax
  380.         sal   ax,8
  381.         sar   dx,8
  382.         idiv  temp
  383.         add   ax,160
  384.         mov   nx,ax
  385.       end;
  386.       tx3:=nx;
  387.       nx:=translated[loop1,3].Y;
  388.       asm
  389.         mov   ax,nx
  390.         mov   dx,ax
  391.         sal   ax,8
  392.         sar   dx,8
  393.         idiv  temp
  394.         add   ax,100
  395.         mov   nx,ax
  396.       end;
  397.       ty3:=nx;
  398.  
  399.  
  400.       temp:=round (translated[loop1,4].z)+zoff;
  401.       nx:=translated[loop1,4].X;
  402.       asm
  403.         mov   ax,nx
  404.         mov   dx,ax
  405.         sal   ax,8
  406.         sar   dx,8
  407.         idiv  temp
  408.         add   ax,160
  409.         mov   nx,ax
  410.       end;
  411.       tx4:=nx;
  412.       nx:=translated[loop1,4].Y;
  413.       asm
  414.         mov   ax,nx
  415.         mov   dx,ax
  416.         sal   ax,8
  417.         sar   dx,8
  418.         idiv  temp
  419.         add   ax,100
  420.         mov   nx,ax
  421.       end;
  422.       ty4:=nx;
  423.  
  424.       drawpoly (tx1,ty1,tx2,ty2,tx3,ty3,tx4,ty4,loop1,vaddr);
  425.     END;
  426.   END;
  427. END;
  428.  
  429.  
  430. {──────────────────────────────────────────────────────────────────────────}
  431. Procedure MoveAround;
  432.   { This is the main display procedure. }
  433. VAR deg,loop1,loop2:integer;
  434.     ch:char;
  435.  
  436. BEGIN
  437.   for loop1:=1 to 15 do
  438.     pal (loop1,0,loop1*4+3,63-(loop1*4+3));
  439.   pal (100,50,50,50);
  440.  
  441.   deg:=0;
  442.   ch:=#0;
  443.   Cls (vaddr,0);
  444.   For loop1:=1 to maxpolys do
  445.     For loop2:=1 to 4 do BEGIN
  446.       Lines [loop1,loop2].x:=a [loop1,loop2,1]*8;
  447.       Lines [loop1,loop2].y:=a [loop1,loop2,2]*8;
  448.       Lines [loop1,loop2].z:=a [loop1,loop2,3]*8;
  449.     END;
  450.  
  451.   cls (vaddr,0);
  452.   cls (vga,0);
  453.   Xoff := 160;
  454.   Yoff:=100;
  455.   zoff:=-500;
  456.  
  457.   ytopclip:=101;
  458.   ybotclip:=100;
  459.   line (0,100,319,100,100,vga);
  460.   delay (2000);
  461.   for loop1:=1 to 25 do BEGIN
  462.     RotatePoints (deg,deg,deg);
  463.     DrawPoints;
  464.     line (0,ytopclip,319,ytopclip,100,vaddr);
  465.     line (0,ybotclip,319,ybotclip,100,vaddr);
  466.     flip (vaddr,vga);
  467.     cls (vaddr,0);
  468.     deg:=(deg+5) mod 360;
  469.     ytopclip:=ytopclip-4;
  470.     ybotclip:=ybotclip+4;
  471.   END;
  472.   Repeat
  473.     if keypressed then ch:=upcase (Readkey);
  474.     RotatePoints (deg,deg,deg);
  475.     DrawPoints;
  476.     line (0,0,319,0,100,vaddr);
  477.     line (0,199,319,199,100,vaddr);
  478.     flip (vaddr,vga);
  479.     cls (vaddr,0);
  480.     deg:=(deg+5) mod 360;
  481.   Until ch=#27;
  482.   for loop1:=1 to 25 do BEGIN
  483.     ytopclip:=ytopclip+4;
  484.     ybotclip:=ybotclip-4;
  485.     RotatePoints (deg,deg,deg);
  486.     DrawPoints;
  487.     line (0,ytopclip,319,ytopclip,100,vaddr);
  488.     line (0,ybotclip,319,ybotclip,100,vaddr);
  489.     flip (vaddr,vga);
  490.     cls (vaddr,0);
  491.     deg:=(deg+5) mod 360;
  492.   END;
  493. END;
  494.  
  495.  
  496. BEGIN
  497.   clrscr;
  498.   writeln ('Welcome to the fourteenth trainer! This one is on glenzing, and also');
  499.   writeln ('throws in a faster poly, fixed point math and a lot more assembler.');
  500.   writeln;
  501.   Writeln ('This isn''t very interactive ... hit any key to start, and then');
  502.   writeln ('hit the [ESC] key to exit. It is a glenzed cube spinning in the');
  503.   writeln ('middle of the screen. Read the text file for more information on');
  504.   writeln ('how the fixed point etc. works ... it will also help a lot if you');
  505.   writeln ('compare it with TUTPROG9.PAS, as this is the same 3D system, just');
  506.   writeln ('speeded up.');
  507.   writeln;
  508.   writeln;
  509.   writeln;
  510.   write ('Hit any key to continue ...');
  511.   readkey;
  512.   SetUpVirtual;
  513.   SetMCGA;
  514.   SetUpPoints;
  515.   MoveAround;
  516.   SetText;
  517.   ShutDown;
  518.   Writeln ('All done. This concludes the fourteenth sample program in the ASPHYXIA');
  519.   Writeln ('Training series. You may reach DENTHOR under the names of GRANT');
  520.   Writeln ('SMITH/DENTHOR/ASPHYXIA on the ASPHYXIA BBS.I also occasinally');
  521.   Writeln ('RSAProg, comp.lang.pascal and comp.sys.ibm.pc.demos. E-mail me at :');
  522.   Writeln ('    smith9@batis.bis.und.ac.za');
  523.   Writeln ('The numbers are available in the main text. You may also write to me at:');
  524.   Writeln ('             Grant Smith');
  525.   Writeln ('             P.O. Box 270');
  526.   Writeln ('             Kloof');
  527.   Writeln ('             3640');
  528.   Writeln ('             Natal');
  529.   Writeln ('             South Africa');
  530.   Writeln ('I hope to hear from you soon!');
  531.   Writeln; Writeln;
  532.   Write   ('Hit any key to exit ...');
  533.   readkey;
  534. END.
  535.